home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PAS_0793 / DTIME.PAS < prev    next >
Pascal/Delphi Source File  |  1993-08-01  |  17KB  |  507 lines
  1. {─ Fido Pascal Conference ────────────────────────────────────────────── PASCAL ─
  2. Msg  : 429 of 457
  3. From : Brian Swanson                       1:123/419.0          08 Jul 93  12:35
  4. To   : Chad Thevis                         1:3811/210.0
  5. Subj : Date-Time Unit Posted by Alan Graff in Nov. of '92[1/2]
  6. ────────────────────────────────────────────────────────────────────────────────}
  7.               (* * * * * * * * * * * * * * * * * * * * * * *)
  8.               (*   UNIT: DTIME - By Alan Graff, Nov. 92    *)
  9.               (*      Compiled from routines found in:     *)
  10.               (*       DATEPAK4: W.G.Madison, Nov. 87      *)
  11.               (*       UNIXDATE: Brian Stark, Jan. 92      *)
  12.               (*   Plus various things of my own creation  *)
  13.               (*   and extracted from Fidonet PASCAL echo  *)
  14.               (*   messages and other sources.             *)
  15.               (*      Contributed to the Public Domain     *)
  16.               (*          Version 1.1 - Nov. 1992          *)
  17.               (* * * * * * * * * * * * * * * * * * * * * * *)
  18.  
  19. UNIT DTime;
  20. {**************************************************************}
  21. INTERFACE
  22. uses crt,dos;
  23.  
  24. TYPE DATETYPE = record
  25.      day:WORD;
  26.      MONTH:WORD;
  27.      YEAR:WORD;
  28.      dow:word;
  29.      end;
  30.  
  31.  (* Sundry determinations of current date/time variables *)
  32. Function  DayOfYear:word;  (* Returns 1 to 365 *)
  33. Function DayOfMonth:word;  (* Returns 1 to 31  *)
  34. Function DayOfWeek:word;   (* Returns 1 to 7   *)
  35. Function MonthOfYear:word; (* Returns 1 to 12  *)
  36. Function ThisYear:word;    (* Returns current year *)
  37. Function ThisHour:word;    (* Returns 1 to 24  *)
  38. Function ThisMinute:word;  (* Returns 0 to 59  *)
  39.   (* Calculate what day of the week a particular date falls on *)
  40. Procedure WkDay(Year,Month,Day:Integer; var WeekDay:Integer);
  41.    (* Full Julian conversions *)
  42. Procedure GregorianToJulianDN(Year,Month,Day:Integer;var JulianDN:LongInt);
  43. Procedure JulianDNToGregorian(JulianDN:LongInt;var Year,Month,Day:Integer);
  44.    (* 365 day Julian conversions *)
  45. Procedure GregorianToJulianDate(Year,Month,Day:Integer;var JulianDate:Integer);
  46. Procedure JulianToGregorianDate(JulianDate,Year:Integer;var Month,Day:Integer);
  47.    (* Sundry string things *)
  48. Function  DateString:String;  (* Returns system date as "mm-dd-yy" string *)
  49. Function  TimeString:String;  (* Returns system time as "00:00:00" string *)
  50.   (* Create current YYMMDD string to use as a file name *)
  51. Function DateAFile(dy,dm,dd:word):string;
  52.   (* Return YY-MM-DD string from filename created by DateAFile func *)
  53. Function Parsefile(s:string):string;
  54.    (* Return values of 1 day ago *)
  55. Procedure Yesterday(Var y,m,d:integer);
  56.    (* Return values of 1 day ahead *)
  57. Procedure Tomorrow(Var y,m,d:integer);
  58.  (* Adjust time based on "TZ" environment *)
  59. Function  GetTimeZone : ShortInt;
  60. Function  IsLeapYear(Source : Word) : Boolean;  (* What it says :-)  *)
  61.   (* Unix date conversions *)
  62. Function Norm2Unix(Y,M,D,H,Min,S:Word):LongInt;
  63. Procedure Unix2Norm(Date:LongInt;Var Y,M,D,H,Min,S:Word);
  64.   (* Determines what day of year Easter falls on *)
  65. Procedure Easter(Year:Word;Var Date:DateType);
  66.   (* Determines what day of year Thanksgiving falls on *)
  67. Procedure Thanksgiving(Year:Word;Var Date:DateType);
  68.   (* Determine what percentage of moon is lit on a particular night *)
  69. Function MoonPhase(Date:Datetype):Real;
  70.  
  71. IMPLEMENTATION
  72.  
  73. const
  74.   D0 =    1461;
  75.   D1 =  146097;
  76.   D2 = 1721119;
  77.   DaysPerMonth :  Array[1..12] of ShortInt =
  78. (031,028,031,030,031,030,031,031,030,031,030,031);
  79.   DaysPerYear  :  Array[1..12] of Integer  =
  80. (031,059,090,120,151,181,212,243,273,304,334,365);
  81.   DaysPerLeapYear :    Array[1..12] of Integer  =
  82. (031,060,091,121,152,182,213,244,274,305,335,366);
  83.   SecsPerYear      : LongInt  = 31536000;
  84.   SecsPerLeapYear  : LongInt  = 31622400;
  85.   SecsPerDay       : LongInt  = 86400;
  86.   SecsPerHour      : Integer  = 3600;
  87.   SecsPerMinute    : ShortInt = 60;
  88.  
  89. Procedure GregorianToJulianDN;
  90. var
  91.   Century,
  92.   XYear    : LongInt;
  93. begin {GregorianToJulianDN}
  94.   If Month <= 2 then begin
  95.     Year := pred(Year);
  96.     Month := Month + 12;
  97.     end;
  98.   Month := Month - 3;
  99.   Century := Year div 100;
  100.   XYear := Year mod 100;
  101.   Century := (Century * D1) shr 2;
  102.   XYear := (XYear * D0) shr 2;
  103.   JulianDN := ((((Month * 153) + 2) div 5) + Day) + D2 + XYear + Century;
  104.   end; {GregorianToJulianDN}
  105. {**************************************************************}
  106. Procedure JulianDNToGregorian;
  107. var
  108.   Temp,
  109.   XYear   : LongInt;
  110.   YYear,
  111.   YMonth,
  112.   YDay    : Integer;
  113. begin {JulianDNToGregorian}
  114.   Temp := (((JulianDN - D2) shl 2) - 1);
  115.   XYear := (Temp mod D1) or 3;
  116.   JulianDN := Temp div D1;
  117.   YYear := (XYear div D0);
  118.   Temp := ((((XYear mod D0) + 4) shr 2) * 5) - 3;
  119.   YMonth := Temp div 153;
  120.   If YMonth >= 10 then begin
  121.     YYear := YYear + 1;
  122.     YMonth := YMonth - 12;
  123.     end;
  124.   YMonth := YMonth + 3;
  125.   YDay := Temp mod 153;
  126.   YDay := (YDay + 5) div 5;
  127.   Year := YYear + (JulianDN * 100);
  128.   Month := YMonth;
  129.   Day := YDay;
  130.   end; {JulianDNToGregorian}
  131. {**************************************************************}
  132. Procedure GregorianToJulianDate;
  133. var
  134.   Jan1,
  135.   Today : LongInt;
  136. begin {GregorianToJulianDate}
  137.   GregorianToJulianDN(Year, 1, 1, Jan1);
  138.   GregorianToJulianDN(Year, Month, Day, Today);
  139.   JulianDate := (Today - Jan1 + 1);
  140.   end; {GregorianToJulianDate}
  141. {**************************************************************}
  142. Procedure JulianToGregorianDate;
  143. var
  144.   Jan1  : LongInt;
  145. begin
  146.   GregorianToJulianDN(Year, 1, 1, Jan1);
  147.   JulianDNToGregorian((Jan1 + JulianDate - 1), Year, Month, Day);
  148.   end; {JulianToGregorianDate}
  149. {**************************************************************}
  150. Procedure WkDay;
  151. var
  152.   DayNum : LongInt;
  153. begin
  154.   GregorianToJulianDN(Year, Month, Day, DayNum);
  155.   DayNum := ((DayNum + 1) mod 7);
  156.   WeekDay := (DayNum) + 1;
  157.   end; {DayOfWeek}
  158. {**************************************************************}
  159. Procedure Yesterday(Var Y,M,D:integer);
  160. var jdn:longint;
  161. begin
  162. GregorianToJulianDN(Y,M,D,JDN);
  163. JDN:=JDN-1;
  164. JulianDNToGregorian(JDN,Y,M,D);
  165. end;
  166. {**************************************************************}
  167. Procedure Tomorrow(Var Y,M,D:integer);
  168. var JDN:longint;
  169. begin
  170. GregorianToJulianDN(Y,M,D,JDN);
  171. JDN:=JDN+1;
  172. JulianDNToGregorian(JDN,Y,M,D);
  173. end;
  174. {**************************************************************}
  175. Function TimeString:string;
  176. var hr,mn,sec,hun:word;
  177. s,q:string;
  178. begin
  179.   q:='';
  180.   gettime(hr,mn,sec,hun);
  181.   if hr<10 then q:=q+'0';
  182.   str(hr:1,s);
  183.   q:=q+s+':';
  184.   if mn<10 then q:=q+'0';
  185.   str(mn:1,s);
  186.   q:=q+s;
  187.   TimeString:=q;
  188. end;
  189. {**************************************************************}
  190. Function ThisHour:Word;
  191. var hr,mn,sec,hun:word;
  192. begin
  193.   gettime(hr,mn,sec,hun);
  194.   ThisHour:=hr;
  195. end;
  196. {**************************************************************}
  197. Function ThisMinute:Word;
  198. var hr,mn,sec,hun:word;
  199. begin
  200.   gettime(hr,mn,sec,hun);
  201.   ThisMinute:=mn;
  202. end;
  203. {**************************************************************}
  204. Function DateString:string;
  205. var yr,mo,dy,dow:word;
  206.     s,q:string;
  207. begin
  208.   q:='';
  209.   getdate(yr,mo,dy,dow);
  210.   if mo<10 then q:=q+'0';
  211.   str(mo:1,s);
  212.   q:=q+s+'-';
  213.   if dy<10 then q:=q+'0';
  214.   str(dy:1,s);
  215.   q:=q+s+'-';
  216.   while yr>100 do yr:=yr-100;
  217.   if yr<10 then q:=q+'0';
  218.   str(yr:1,s);
  219.   q:=q+s;
  220.   Datestring:=q;
  221. end;
  222. {**************************************************************}
  223. Function parsefile(s:string):string;  { Return date string from a file name }
  224. var mo,errcode:word;                  { in either YYMMDD.EXT or MMDDYY.EXT  }
  225.     st:string;                        { format.                             }
  226. begin
  227. st:=copy(s,1,2)+'-'+copy(s,3,2)+'-'+copy(s,5,2);
  228. parsefile:=st;
  229. end;
  230. {**************************************************************}
  231. function dateafile(dy,dm,dd:word):string;
  232. var s1,s2:string;
  233. begin
  234. while dy>100 do dy:=dy-100;
  235. str(dy,s1);
  236. while length(s1)<2 do s1:='0'+s1;
  237. s2:=s1;
  238. str(dm,s1);
  239. while length(s1)<2 do s1:='0'+s1;
  240. s2:=s2+s1;
  241. str(dd,s1);
  242. while length(s1)<2 do s1:='0'+s1;
  243. s2:=s2+s1;
  244. dateafile:=s2;
  245. end;
  246. {**************************************************************}
  247. Function DayOfMonth:Word;
  248. var yr,mo,dy,dow:word;
  249. begin
  250.   getdate(yr,mo,dy,dow);
  251.   DayOfMonth:=dy;
  252. end;
  253. {**************************************************************}
  254. Function ThisYear:Word;
  255. var yr,mo,dy,dow:word;
  256. begin
  257.   getdate(yr,mo,dy,dow);
  258.   ThisYear:=yr;
  259. end;
  260. {**************************************************************}
  261. Function DayOfWeek:word;
  262. var yr,mo,dy,dow:word;
  263. begin
  264.   getdate(yr,mo,dy,dow);    (* Turbo Pascal authors never saw a *)
  265.   dow:=dow+1;               (* calendar.  Their first day of    *)
  266.   if dow=8 then dow:=1;     (* week is Monday....               *)
  267.   DayOfWeek:=dow;
  268. end;
  269. {**************************************************************}
  270. Function MonthOfYear:Word;
  271. var yr,mo,dy,dow:word;
  272. begin
  273.   getdate(yr,mo,dy,dow);
  274.   monthofyear:=mo;
  275. end;
  276. {**************************************************************}
  277. Function GetTimeZone : ShortInt;
  278. Var
  279.   Environment : String;
  280.   Index : Integer;
  281. Begin
  282.   GetTimeZone := 0;                            {Assume UTC}
  283.   Environment := GetEnv('TZ');       {Grab TZ string}
  284.   For Index := 1 To Length(Environment) Do
  285.     Environment[Index] := Upcase(Environment[Index]);
  286.   If Environment =  'EST05'    Then GetTimeZone := -05; {USA EASTERN}
  287.   If Environment =  'EST05EDT' Then GetTimeZone := -06;
  288.   If Environment =  'CST06'    Then GetTimeZone := -06; {USA CENTRAL}
  289.   If Environment =  'CST06CDT' Then GetTimeZone := -07;
  290.   If Environment =  'MST07'    Then GetTimeZone := -07; {USA MOUNTAIN}
  291.   If Environment =  'MST07MDT' Then GetTimeZone := -08;
  292.   If Environment =  'PST08'    Then GetTimeZone := -08;
  293.   If Environment =  'PST08PDT' Then GetTimeZone := -09;
  294.   If Environment =  'YST09'    Then GetTimeZone := -09;
  295.   If Environment =  'AST10'    Then GetTimeZone := -10;
  296.   If Environment =  'BST11'    Then GetTimeZone := -11;
  297.   If Environment =  'CET-1'    Then GetTimeZone :=  01;
  298.   If Environment =  'CET-01'   Then GetTimeZone :=  01;
  299.   If Environment =  'EST-10'   Then GetTimeZone :=  10;
  300.   If Environment =  'WST-8'    Then GetTimeZone :=  08; {Perth,W.Austrailia}
  301.   If Environment =  'WST-08'   Then GetTimeZone :=  08;
  302. End;
  303. {**************************************************************}
  304. Function IsLeapYear(Source : Word) : Boolean;
  305. Begin
  306.   If (Source Mod 4 = 0) Then
  307.     IsLeapYear := True
  308.   Else
  309.     IsLeapYear := False;
  310. End;
  311. {**************************************************************}
  312. Function Norm2Unix(Y,M,D,H,Min,S : Word) : LongInt;
  313. Var
  314.   UnixDate : LongInt;
  315.   Index    : Word;
  316. Begin
  317.   UnixDate := 0;                                              {initialize}
  318.   Inc(UnixDate,S);                                           {add seconds}
  319.   Inc(UnixDate,(SecsPerMinute * Min));                       {add minutes}
  320.   Inc(UnixDate,(SecsPerHour * H));                             {add hours}
  321.   UnixDate := UnixDate - (GetTimeZone * SecsPerHour);         {UTC offset}
  322.   If D > 1 Then                              {has one day already passed?}
  323.     Inc(UnixDate,(SecsPerDay * (D-1)));
  324.   If IsLeapYear(Y) Then
  325.     DaysPerMonth[02] := 29
  326.   Else
  327.     DaysPerMonth[02] := 28;                          {Check for Feb. 29th}
  328.   Index := 1;
  329.   If M > 1 Then For Index := 1 To (M-1) Do {has one month already passed?}
  330.     Inc(UnixDate,(DaysPerMonth[Index] * SecsPerDay));
  331.   While Y > 1970 Do
  332.   Begin
  333.     If IsLeapYear((Y-1)) Then
  334.       Inc(UnixDate,SecsPerLeapYear)
  335.     Else
  336.       Inc(UnixDate,SecsPerYear);
  337.     Dec(Y,1);
  338.   End;
  339.   Norm2Unix := UnixDate;
  340. End; Procedure Unix2Norm(Date : LongInt; Var Y, M, D, H, Min, S : Word);
  341. {}
  342. Var
  343.   LocalDate : LongInt; Done : Boolean; X : ShortInt; TotDays : Integer;
  344. Begin
  345.   Y   := 1970; M := 1; D := 1; H := 0; Min := 0; S := 0;
  346.   LocalDate := Date + (GetTimeZone * SecsPerHour);      {Local time date}
  347.   Done := False;
  348.   While Not Done Do
  349.   Begin
  350.     If LocalDate >= SecsPerYear Then
  351.     Begin
  352.       Inc(Y,1);
  353.       Dec(LocalDate,SecsPerYear);
  354.     End
  355.     Else
  356.       Done := True;
  357.     If (IsLeapYear(Y+1)) And (LocalDate >= SecsPerLeapYear) And
  358.        (Not Done) Then
  359.     Begin
  360.       Inc(Y,1);
  361.       Dec(LocalDate,SecsPerLeapYear);
  362.     End;
  363.   End;
  364.   M := 1; D := 1;
  365.   Done := False;
  366.   TotDays := LocalDate Div SecsPerDay;
  367.   If IsLeapYear(Y) Then
  368.   Begin
  369.     DaysPerMonth[02] := 29;
  370.     X := 1;
  371.     Repeat
  372.       If (TotDays <= DaysPerLeapYear[x]) Then
  373.       Begin
  374.         M := X;
  375.         Done := True;
  376.         Dec(LocalDate,(TotDays * SecsPerDay));
  377.         D := DaysPerMonth[M]-(DaysPerLeapYear[M]-TotDays) + 1;
  378.       End
  379.       Else
  380.         Done := False;
  381.       Inc(X);
  382.     Until (Done) or (X > 12);
  383.   End
  384.   Else
  385.   Begin
  386.     DaysPerMonth[02] := 28;
  387.     X := 1;
  388.     Repeat
  389.       If (TotDays <= DaysPerYear[x]) Then
  390.       Begin
  391.         M := X;
  392.         Done := True;
  393.         Dec(LocalDate,(TotDays * SecsPerDay));
  394.         D := DaysPerMonth[M]-(DaysPerYear[M]-TotDays) + 1;
  395.       End
  396.       Else
  397.         Done := False;
  398.       Inc(X);
  399.     Until Done = True or (X > 12);
  400.   End;
  401.   H := LocalDate Div SecsPerHour;
  402.     Dec(LocalDate,(H * SecsPerHour));
  403.   Min := LocalDate Div SecsPerMinute;
  404.     Dec(LocalDate,(Min * SecsPerMinute));
  405.   S := LocalDate;
  406. End;
  407. {**************************************************************}
  408. Function DayOfYear;
  409. var
  410.   HCentury,Century,Xyear,
  411.   Ripoff,HXYear    : LongInt;
  412.   Holdyear,Holdmonth,Holdday:Integer;
  413.   year,month,day,dofwk:word;
  414. begin {DayofYear}
  415.   getdate(year,month,day,dofwk);
  416.   Holdyear:=year-1;
  417.   Holdmonth:=9;
  418.   Holdday:=31;
  419.   HCentury := HoldYear div 100;
  420.   HXYear := HoldYear mod 100;
  421.   HCentury := (HCentury * D1) shr 2;
  422.   HXYear := (HXYear * D0) shr 2;
  423.   Ripoff := ((((HoldMonth * 153) + 2) div 5) + HoldDay) + D2 + HXYear +
  424. HCentury;
  425.   If Month <= 2 then begin
  426.     Year := pred(Year);
  427.     Month := Month + 12;
  428.     end;
  429.   Month := Month - 3;
  430.   Century := Year div 100;
  431.   XYear := Year mod 100;
  432.   Century := (Century * D1) shr 2;
  433.   XYear := (XYear * D0) shr 2;
  434.   DayofYear := (((((Month * 153) + 2) div 5) + Day) + D2 + XYear + Century)-
  435. ripoff;
  436.   end; {DayOfYear}
  437. Procedure Easter(Year : Word; Var Date : DateType);
  438.    (* Calculates what day Easter falls on in a given year         *)
  439.    (* Set desired Year and result is returned in Date variable    *)
  440. Var
  441.    GoldenNo,
  442.    Sun,
  443.    Century,
  444.    LeapCent,
  445.    LunarCorr,
  446.    Epact,
  447.    FullMoon : Integer;
  448. Begin
  449.    Date.Year := Year;
  450.    GoldenNo := (Year Mod 19) + 1;
  451.    Century := (Year Div 100) + 1;
  452.    LeapCent := (3 * Century Div 4) - 12;
  453.    LunarCorr := ((8 * Century + 5) Div 25) - 5;
  454.    Sun := (5 * Year Div 4) - LeapCent - 10;
  455.    Epact := Abs(11 * GoldenNo + 20 + LunarCorr - LeapCent) Mod 30;
  456.    If ((Epact = 25) And (GoldenNo > 11)) Or (Epact = 24) then
  457.       Inc(Epact);
  458.    FullMoon := 44 - Epact;
  459.    If FullMoon < 21 then
  460.       Inc(FullMoon, 30);
  461.    Date.Day := FullMoon + 7 - ((Sun + FullMoon) Mod 7);
  462.    If Date.Day > 31 then
  463.       Begin
  464.          Dec(Date.Day, 31);
  465.          Date.Month := 4;
  466.       End
  467.    Else
  468.       Date.Month := 3;
  469.    Date.DOW := 0;
  470. End;
  471. {**************************************************************}
  472. Procedure Thanksgiving(Year : Word; Var Date : DateType);
  473.    (* Calculates what day Thanksgiving falls on in a given year   *)
  474.    (* Set desired Year and result is returned in Date variable    *)
  475. Var
  476.   Counter,WeekDay:Word;
  477.   Daynum:longint;
  478. Begin
  479.    Date.Year := Year;
  480.    Date.Month := 11;
  481.    counter:=29;
  482.    repeat
  483.      dec(counter);
  484.      GregorianToJulianDN(Date.Year, Date.Month, Counter, DayNum);
  485.      DayNum := ((DayNum + 1) mod 7);
  486.      WeekDay := (DayNum) + 1;
  487.    Until Weekday = 5;
  488.    Date.Day:=Counter;
  489. End;
  490. {*************************************************************}
  491. Function MoonPhase(Date:Datetype):Real;
  492.   (* Determines APPROXIMATE phase of the moon (percentage lit)   *)
  493.   (* 0.00 = New moon, 1.00 = Full moon                           *)
  494.   (* Due to rounding, full values may possibly never be reached  *)
  495.   (* Valid from Oct. 15, 1582 to Feb. 28, 4000                   *)
  496.   (* Calculations adapted to Turbo Pascal from routines found in *)
  497.   (* "119 Practical Programs For The TRS-80 Pocket Computer"     *)
  498.   (* John Clark Craig, TAB Books, 1982                      (Ag) *)
  499. VAR j:longint; m:real;
  500. Begin
  501.   GregorianToJulianDN(Date.Year,Date.Month,Date.Day,J);
  502.   M:=(J+4.867)/ 29.53058;
  503.   M:=2*(M-Int(m))-1;
  504.   MoonPhase:=Abs(M);
  505. end;
  506.  
  507. END.